home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 1995 #5 & #6 / Amiga Plus CD - 1995 - No. 5 and 6.iso / pd / netz / ums / ums-beta / rexxdossupport / txt / rxlibssupport.mod < prev   
Text File  |  1994-05-07  |  5KB  |  161 lines
  1. (*(***********************************************************************
  2.  
  3. :Program.    RxLibsSupport.mod
  4. :Contents.   support functions for rexx function libraries
  5. :Author.     hartmtut Goebel [hG]
  6. :Address.    Aufseßplatz 5, D-90459 Nürnberg
  7. :Address.    UseNet: hartmut@oberon.nbg.sub.org
  8. :Address.    Z-Netz: hartmut@asn.zer   Fido: 2:246/81.1
  9. :Copyright.  Copyright © 1994 by hartmtut Goebel
  10. :Language.   Oberon-2
  11. :Translator. Amiga Oberon 3.0
  12. :Imports.    Printf (Volker Rudolph), MoreStrings [hG]
  13. :Version.    $VER: RxLibsSupport.mod 1.1 (7.5.94) Copyright © 1994 by hartmtut Goebel
  14.  
  15. (* $StackChk- $NilChk- $RangeChk- $CaseChk- $OvflChk- $ReturnChk- $ClearVars- *)
  16. (****i* /--history-- ***************************************
  17. *
  18. *  1.1  07 May 1994
  19. *       · added ArgsPresent()
  20. *
  21. *  1.0  23 Jan 1994
  22. *       · initial release
  23. *
  24. *********************************************************************)*)*)
  25.  
  26. MODULE RxLibsSupport;
  27.  
  28. IMPORT
  29.   e := Exec,
  30.   str := Strings,
  31.   pf := Printf,
  32.   ms := MoreStrings,
  33.   ol := OberonLib,
  34.   rx := Rexx,
  35.   rxs := RexxSysLib,
  36.   rvi := RVI,
  37.   y := SYSTEM;
  38.  
  39. CONST
  40.   versionString = "$VER: RxLibsSupport 1.1 (7.5.94) Copyright © 1994 by hartmtut Goebel";
  41.  
  42.   strTRUE  * = "1";
  43.   strFALSE * = "0";
  44.  
  45.   progNotFound * = rx.err10001;
  46.   noMemory     * = rx.err10003;
  47.   badNumArgs   * = rx.err10017;
  48.  
  49. TYPE
  50.   ConvertLongBuffer * = ARRAY 16 OF CHAR;
  51.   Function * = PROCEDURE (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
  52.  
  53.   FunctionListEntry * = STRUCT
  54.     name     *: e.LSTRPTR;
  55.     minArgs  *: INTEGER;
  56.     maxArgs  *: INTEGER;
  57.     function *: Function;
  58.   END;
  59.  
  60.   FunctionList = ARRAY OF FunctionListEntry;
  61.  
  62. (* ---------------------------------------------------------------- *)
  63.  
  64. PROCEDURE SetRC * (msg: rx.RexxMsgPtr; rc: LONGINT): INTEGER;
  65. VAR
  66.   longbuff: ConvertLongBuffer;
  67. BEGIN
  68.   pf.SPrintf1( longbuff, "%ld", rc);                                    (*$RangeChk-*)
  69.   RETURN SHORT(rvi.SetRexxVar(msg,"RC",longbuff,str.Length(longbuff))); (*$RangeChk=*)
  70. END SetRC;
  71.  
  72. PROCEDURE SetRC5 * (msg: rx.RexxMsgPtr): INTEGER;
  73. BEGIN                                           (*$RangeChk-*)
  74.   RETURN SHORT(rvi.SetRexxVar(msg,"RC","5",1)); (*$RangeChk=*)
  75. END SetRC5;
  76.  
  77. PROCEDURE SetRC0 * (msg: rx.RexxMsgPtr): INTEGER;
  78. BEGIN                                           (*$RangeChk-*)
  79.   RETURN SHORT(rvi.SetRexxVar(msg,"RC","0",1)); (*$RangeChk=*)
  80. END SetRC0;
  81.  
  82. (* ---------------------------------------------------------------- *)
  83.  
  84. (* IsValidArg()
  85.  *
  86.  * testes whether arguments <argNum> is a valid arguments, this
  87.  * means is either not given or the first charakter is <c>.
  88.  * <set> will be true if the argument is given and is valid,
  89.  * false otherwise.
  90.  *)
  91. PROCEDURE IsValidArg * (msg: rx.RexxMsgPtr;
  92.                         argNum: INTEGER;
  93.                         c: CHAR;
  94.                         VAR set: BOOLEAN): BOOLEAN;
  95. BEGIN
  96.   set := FALSE;
  97.   IF (rx.ActionArg(msg.action) < argNum) OR (msg.args[argNum] = NIL) THEN
  98.     RETURN TRUE;
  99.   ELSIF CAP(msg.args[argNum][0]) = c THEN
  100.     set := TRUE;
  101.     RETURN TRUE;
  102.   ELSE
  103.     RETURN FALSE;
  104.   END;
  105. END IsValidArg;
  106.  
  107.  
  108. (* ArgsPresent()
  109.  *
  110.  * checks whether all arguments between <start> and <stop> (including both)
  111.  * are present (non-null)
  112.  *)
  113.  
  114. PROCEDURE ArgsPresent * (msg: rx.RexxMsgPtr; start, stop: INTEGER): BOOLEAN;
  115. BEGIN
  116.   WHILE start <= stop DO
  117.     IF msg.args[start] = NIL THEN RETURN FALSE; END;
  118.     INC(start);
  119.   END;
  120.   RETURN TRUE;
  121. END ArgsPresent;
  122.  
  123. (* ---------------------------------------------------------------- *)
  124.  
  125. PROCEDURE Dispatch * (msg: rx.RexxMsgPtr;
  126.                       VAR resultStr: e.LSTRPTR;
  127.                       functionList: FunctionList): LONGINT;   (* $CopyArrays- *)
  128. VAR
  129.   func: FunctionListEntry;
  130.   retval: LONGINT;
  131.   i, numArgs: INTEGER;
  132. BEGIN
  133.   resultStr := NIL;
  134.   IF (msg = NIL) OR (rx.ActionCode(msg.action) # rx.rxFunc) THEN
  135.     RETURN progNotFound;
  136.   END;
  137.   i := 0;
  138.   LOOP
  139.     IF i >= LEN(functionList) THEN
  140.       RETURN progNotFound; END;
  141.     IF ms.NCStrCmp(functionList[i].name^,msg.args[0]^) = 0 THEN
  142.       EXIT; END;
  143.     INC(i);
  144.   END;
  145.  
  146.   numArgs := (*$RangeChk-*) SHORT(rx.ActionArg(msg.action)); (*$RangeChk=*)
  147.   IF (numArgs < functionList[i].minArgs) OR (numArgs > functionList[i].maxArgs) THEN
  148.     RETURN badNumArgs;
  149.   END;
  150.  
  151.   retval := functionList[i].function(msg, resultStr);
  152.   IF (retval = rx.ok) & (resultStr = NIL) THEN
  153.     resultStr := rxs.CreateArgstring("",0);
  154.     IF resultStr = NIL THEN retval := noMemory; END;
  155.   END;
  156.   RETURN retval;
  157. END Dispatch;
  158.  
  159. END RxLibsSupport.
  160.  
  161.